home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / link / hpsuspend.t < prev    next >
Text File  |  1988-05-02  |  7KB  |  179 lines
  1. (herald hpsuspend (env tsys (link suspend)))
  2.  
  3. ;;; Look at a Unix a.out description and template.doc
  4.  
  5. (define (suspend obj out-spec x?)
  6.   (set (experimental?) x?)
  7.   (really-suspend obj out-spec 'o))
  8.  
  9. (define initial-symbol-count 0)
  10.  
  11.  
  12. (define-constant RELOC-SIZE 8)
  13. (define-constant CYMBOL-SIZE 8)
  14. (define-constant N_TEXT #o2)
  15. (define-constant N_DATA #o3)
  16. (define-constant N_UNDF 0)
  17. (define-constant N_EXT #o40)         
  18. (define-constant R_TEXT (fx+ (fixnum-ashl 0 8) 2))  ; 0 for text, 2 for long
  19. (define-constant R_DATA (fx+ (fixnum-ashl 1 8) 2))  ; 1 for data, 2 for long
  20. (define-constant R_UNDF (fx+ (fixnum-ashl 3 8) 2))  ; 3 for undf, 2 for long
  21.  
  22. (define (vgc-foreign foreign)
  23.   (let* ((heap (lstate-impure *lstate*))
  24.          (addr (+area-frontier heap))
  25.          (name (foreign-name foreign))
  26.          (desc (object nil
  27.                  ((heap-stored self) (lstate-impure *lstate*))
  28.                  ((heap-offset self) addr)
  29.                  ((write-descriptor self stream)
  30.                   (write-data stream (fx+ addr tag/extend)))
  31.                  ((write-store self stream)
  32.                   (write-int stream header/foreign)
  33.                   (write-slot name stream)
  34.                   (write-int stream 0)))))
  35.     (set (+area-frontier heap) (fx+ addr 12))
  36.     (push (+area-objects heap) desc)
  37.     (set-lp-table-entry (lstate-reloc *lstate*) foreign desc)
  38.     (generate-slot-relocation name (fx+ addr 4))
  39.     (cymbol-thunk (symbol->string name) (fixnum-logior N_UNDF N_EXT) 0)
  40.     (reloc-thunk (fx+ addr 8) (lstate-symbol-count *lstate*) R_UNDF)
  41.     (modify (lstate-symbol-count *lstate*) (lambda (x) (fx+ x 1)))
  42.     desc))
  43.  
  44. (define (generate-slot-relocation obj slot-address)
  45.   (cond ((or (fixnum? obj) (immediate? obj)))
  46.         ((eq? (heap-stored (vgc obj)) (lstate-impure *lstate*))
  47.          (reloc-thunk slot-address 0 R_DATA))
  48.         (else
  49.          (reloc-thunk slot-address 0 R_TEXT))))
  50.             
  51. (define (text-relocation addr)
  52.   (reloc-thunk addr 0 R_TEXT))
  53.  
  54. (define (data-relocation addr)
  55.   (reloc-thunk addr 0 R_DATA))
  56.  
  57. (define (reloc-thunk address symbolnum type)
  58.   (push (lstate-data-reloc *lstate*) 
  59.         (cons address (fx+ (fixnum-ashl symbolnum 16) type))))
  60.  
  61. (define (write-slot obj stream)
  62.   (cond ((fixnum? obj)
  63.          (write-fixnum stream obj))
  64.         ((immediate? obj)
  65.          (write-immediate stream obj))
  66.         ((null? obj)
  67.          (write-descriptor (lstate-null *lstate*) stream))
  68.         ((lp-table-entry (lstate-reloc *lstate*) obj)
  69.          => (lambda (desc) (write-descriptor desc stream)))
  70.         (else
  71.          (error "bad immediate type ~s" obj))))
  72.  
  73. (define-integrable (write-int stream int)
  74.   (write-half stream (fixnum-ashr int 16))
  75.   (write-half stream int))
  76.                        
  77. (define-integrable (write-immediate stream imm)
  78.   (let ((int (descriptor->fixnum imm)))
  79.     (write-half stream (fixnum-ashr int 14))
  80.     (write-half stream (fx+ (fixnum-ashl int 2) 1))))
  81.                                                      
  82. (define-integrable (write-scratch stream obj i)
  83.   (let ((offset (fixnum-ashl i 2)))
  84.     (write-half stream (mref-16-u obj offset))
  85.     (write-half stream (mref-16-u obj (fx+ offset 2)))))
  86.     
  87. (define-integrable (write-half stream int)
  88.   (vm-write-byte stream (fixnum-ashr int 8))
  89.   (vm-write-byte stream int))
  90.  
  91. ;(define-integrable (write-byte stream n)
  92. ;  (writec stream (ascii->char (fixnum-logand n 255))))
  93.  
  94. (define-integrable (write-fixnum stream fixnum)
  95.   (write-half stream (fixnum-ashr fixnum 14))
  96.   (write-half stream (fixnum-ashl fixnum 2)))
  97.  
  98.  
  99. (define (cymbol-thunk string type value)
  100.  (push (lstate-symbols *lstate*)              
  101.    (let ((len (string-length string)))
  102.      (object (lambda (stream)     
  103.                (if (fixnum? value)
  104.                    (write-int stream 0)
  105.                    (write-descriptor value stream))
  106.                (vm-write-byte stream type)
  107.                (vm-write-byte stream len)
  108.                (write-int stream 0)
  109.                (write-string stream string))
  110.              ((cymbol-thunk.length self) len)))))
  111.  
  112. (define-operation (cymbol-thunk.length thunk))
  113.  
  114. (define (compute-cymbol-table-size)
  115.   (do ((cyms (lstate-symbols *lstate*) (cdr cyms))
  116.        (size 0 (fx+ size (fx+ 10 (cymbol-thunk.length (car cyms))))))
  117.       ((null? cyms) size)))                                            
  118.  
  119.  
  120. (define-integrable (write-data stream int)
  121.   (write-int stream (fx+ (lstate-pure-size *lstate*) int)))
  122.  
  123. (define (write-zeroes stream n)
  124.   (do ((i 0 (fx+ i 1)))
  125.       ((fx= i n) t)
  126.     (write-int stream 0)))
  127.  
  128. (define (make-global-cymbol proc name)
  129.   (cond ((lp-table-entry (lstate-reloc *lstate*) proc)
  130.        => (lambda (desc)                                
  131.             (cymbol-thunk (string-downcase! (symbol->string name))
  132.                           (fixnum-logior N_DATA N_EXT)
  133.                           desc)))
  134.       (else
  135.        (error "~s not defined" name))))
  136.  
  137.  
  138. (define (write-link-file stream)                 
  139.   (make-global-cymbol big_bang 'big_bang)
  140.   (make-global-cymbol interrupt_dispatcher 'interrupt_dispatcher)
  141.   (write-header     stream)
  142.   (write-area       stream (lstate-pure *lstate*))
  143.   (write-area       stream (lstate-impure *lstate*))
  144.   (write-cymbol-table stream (reverse (lstate-symbols *lstate*)))
  145.   (write-relocation stream (lstate-data-reloc *lstate*)))  
  146.  
  147. (define (write-header stream)
  148.   (let* ((text-size (+area-frontier (lstate-pure *lstate*)))
  149.          (data-size (+area-frontier (lstate-impure *lstate*))))
  150.     (write-half stream #x20C)                 ; system-id
  151.     (write-half stream #x106)                 ; file format
  152.     (write-zeroes stream 2)
  153.     (write-int stream text-size)              ;text segment size
  154.     (write-int stream data-size)              ;data segment size
  155.     (write-zeroes stream 2)                      ;bss  segment size
  156.     (write-int stream (fx* (length (lstate-data-reloc *lstate*)) RELOC-SIZE))
  157.     (write-int stream 0)
  158.     (write-int stream (compute-cymbol-table-size))
  159.     (write-zeroes stream 6))) 
  160.  
  161. (define (write-area stream area)
  162.   (walk (lambda (x) (write-store x stream))
  163.         (reverse! (+area-objects area))))
  164.  
  165.  
  166. (define (write-relocation stream items)
  167.   (walk (lambda (reloc) 
  168.           (write-int stream (car reloc))   ; address
  169.           (write-int stream (cdr reloc)))
  170.         (sort-list! items 
  171.                     (lambda (x y)      
  172.                       (fx< (car x) (car y))))))
  173.  
  174.                              
  175. (define (write-cymbol-table stream cyms)
  176.   (walk (lambda (thunk) (thunk stream)) cyms))
  177.  
  178.  
  179.